
if {![info exists eTraceDir]} {set eTraceDir "C:/Program Files/AutoTrace"}
if {![info exists eCacheDir]} {
	if {![info exists eWorkDir]} {
		set eCacheDir "C:/Windows/Temp"
	} else {
		set eCacheDir cache
	}
}

set eTraceColors [iarray::code [iarray::Array #auto {
	{0.000 0.000 0.000 1.000} black
	{0.000 0.000 0.000 0.498} grey
	{0.000 0.502 0.502 0.498} maroon
	{0.000 0.000 0.502 0.498} olive
	{0.502 0.000 0.502 0.498} green
	{0.502 0.000 0.000 0.498} teal
	{0.502 0.502 0.000 0.498} navy
	{0.000 0.502 0.000 0.498} purple
	{0.000 0.000 0.000 0.000} white
	{0.000 0.000 0.000 0.247} lightgrey
	{0.000 1.000 1.000 0.000} red
	{0.000 0.000 1.000 0.000} yellow
	{1.000 0.000 1.000 0.000} lime
	{1.000 0.000 0.000 0.000} cyan
	{1.000 1.000 0.000 0.000} blue
	{0.000 1.000 0.000 0.000} magenta

	{1.000 0.498 0.000 0.000} skyblue
	{0.000 0.251 0.502 0.482} saddlebrown
	{0.000 0.471 0.722 0.012} coral
	
	{0.000 0.000 0.000 0.984} dimblack
}]]

set cMapParams {ArrowColor 1 {} 0 0 0}
set cMapBorderParams {BorderBlack 1 {} 0 0 0}
set cMapBorderModifiers {"" "\$MapDrawingScale mul" "\$MapDrawingScale mul" "\$MapDrawingScale mul" "" ""}
set cBorderModifierTypes {string number numberlist number enum enum}

proc traceImage {imgFileSpec {isFilled 0} {roundness 0}} {
	global eTraceDir eCacheDir
	
	assert {[string is integer $roundness] && ($roundness >= 0)} {
		Roundness needs to be a non-negative integer.
	}
	
	set imgFileSpec [absolve $imgFileSpec]
	assert {[file exists $imgFileSpec]} {Image file $imgFileSpec not found}
	if $isFilled {set traceMode f} else {set traceMode s}
	set docFileSpec [absolve "$eCacheDir/[file rootname [file tail $imgFileSpec]]_$traceMode$roundness.eps"]
	
	if {[file exists $docFileSpec]} {
		file stat $imgFileSpec imgStat
		file stat $docFileSpec docStat
		if {$imgStat(mtime) < $docStat(mtime)} {
			inform "$imgFileSpec unchanged. Using previous conversion."
			return $docFileSpec
		}
		inform "$imgFileSpec changed. Retracing..."
	} else {
		if {![file exists [file dirname $docFileSpec]]} {
			file mkdir [file dirname $docFileSpec]
		}
		inform "$imgFileSpec new. Tracing..."
	}
	
	set pwd [pwd]
	cd $eTraceDir

	set arguments "-filter-iterations $roundness -output-format eps -output-file $docFileSpec"
	if {!$isFilled} {lappend arguments "-centerline"}
	lappend arguments $imgFileSpec
	# TODO: Guard against wrong input
	eval exec autotrace.exe $arguments

	cd $pwd
	return $docFileSpec
}

proc readEncapsulatedImage {imageArray fileSpec operator} {
	global eTraceColors
	
	set eNumber "\[-\]?\[0-9.\]+"

	set I [iexpect::Expect #auto -white -file [absolve $fileSpec]]

	$I expect line "^%%BoundingBox: ?($eNumber $eNumber $eNumber $eNumber)$" {
		set bbox [$I get match 1]
	} default {
		$I continue
	}

	set image {}
	set curving 0

	$I expect line "^($eNumber $eNumber $eNumber $eNumber) \[kK\]$" {
		assert {!$curving} "Color change inside curve"
		set color [$I get match 1]
		if [$eTraceColors has $color] {
			set color [$eTraceColors of $color]
		} elseif {![$imageArray has $color]} {
			inform "No trace color definition for $color"
		}
		if [$imageArray has $color] {
			set image [$imageArray of $color]
		} else {
			set image [iarray::code [Image #auto [list operator $operator]]]
			if {[llength $bbox]} {
				eval [list $image setBBox] $bbox
			}
			$image setRounding 6
			$imageArray acquire $color $image
		}
		$I continue
	} "^($eNumber $eNumber) m$" {
		assert {[string length $image]} "no color for curve"
		assert {!$curving} "moveto inside curve"
		set curving 1
		$image moveTo [$I get match 1]
		$I continue
	} "^($eNumber $eNumber) l$" {
		assert {[string length $image]} "no color for curve"
		assert {$curving} "lineto outside curve"
		$image lineTo [$I get match 1]
		$I continue
	} "^($eNumber $eNumber) ($eNumber $eNumber) ($eNumber $eNumber) c$" {
		assert {[string length $image]} "no color for curve"
		assert {$curving} "curveto outside curve"
		$image curveTo [$I get match 1] [$I get match 2] [$I get match 3]
		$I continue
	} "^\[Sf\]$" {
		assert {[string length $image]} "no color for curve"
		assert {$curving} "stroke outside curve"
		set curving 0
		$I continue
	} default {
		$I continue
	}
	
	itcl::delete object $I
}

proc readRawImage {imageArray fileSpec operator {isFilled 0} {roundness 0} {summarize 0}} {
	set encapsulatedFileSpec [traceImage $fileSpec $isFilled $roundness]
	readEncapsulatedImage $imageArray $encapsulatedFileSpec $operator
	
	if {![llength [$imageArray names]]} {
		inform "No images in image file <$fileSpec>"
	} else {
		set summarizeLevel [lindex $summarize 0]
		if {$summarizeLevel != 0} {
			if {$summarizeLevel == 1} {
				inform "BBox for image file <$fileSpec>: [[$imageArray of [lindex [$imageArray names] 0]] getBBox]"
			} else {
				inform "Image file <$fileSpec>:"
				switch $summarizeLevel 2 {
					selectImages $imageArray [lindex $summarize 1] summarizeImage [lrange $summarize 2 end]
				} 3 {
					selectImages $imageArray [lindex $summarize 1] summarizeBorder [lrange $summarize 2 end]
				} 4 {
					selectImages $imageArray [lindex $summarize 1] summarizeLocation [lrange $summarize 2 end]
				} default {
					inform "Choose a summarize level between 0 and 4"
				}
			}
		}
	}
}

# mirror:
#    0: Don't mirror -> corner is bottom left
#    1: Mirror left-right -> corner is bottom right
#    2: Mirror across center point -> corner is top right
#    3: Mirror up-down -> corner is top left
proc closeImageEdge {imageArray nonCornerColors {cornerColors {}} {edgeDistance 4} {mirror 0}} {
	if {![string length $edgeDistance]} {set edgeDistance 4}
	if {![string length $mirror]} {set mirror 0}
	switch -- $mirror 0 {
		set mirrorActions {}
	} 1 {
		set mirrorActions mirrorX
	} 2 {
		set mirrorActions {mirrorX mirrorY}
	} 3 {
		set mirrorActions mirrorY
	} default {
		assert false {Image close edge mirror values are restricted to 0, 1, 2 and 3}
	}
	foreach color $nonCornerColors {
		if {![$imageArray has $color]} {
			inform "Non-corner color $color not present in image"
			continue
		}
		set image [$imageArray of $color]
		foreach action $mirrorActions {
			$image $action
		}
		$image closeEdge $edgeDistance 0
		foreach action $mirrorActions {
			$image $action
		}
	}
	foreach color $cornerColors {
		if {![$imageArray has $color]} {
			inform "Corner color $color not present in image"
			continue
		}
		set image [$imageArray of $color]
		foreach action $mirrorActions {
			$image $action
		}
		$image closeEdge $edgeDistance 1
		foreach action $mirrorActions {
			$image $action
		}
	}	 
}

# mirror:
#    0: Don't mirror
#    1: Mirror left-right
#    2: Mirror across center point
#    3: Mirror up-down
# rotate:
#    0: Don't rotate
#    1: Rotate 90 degrees counterclockwise
#    2: Rotate 180 degrees
#    3: Rotate 90 degrees clockwise
# translateX, translateY:
#    Translation components. Only relevant when superimposing two different images.
#    Can be expressions.
# compress:
#    Compresses the image either with a scale of {c 1} or {1 1/c} depending on whether c is smaller than 1 or not.
#    Note that this number can also be an expression, such as 6/7. for a quotient-like compression.
#    (In the example given, the dot is needed, because 6/7 would return 0 as Tcl treats this as integer division.)
# scale:
#    Scales the image. Only relevant when superimposing two different images of different scales.
#    Note that scaling up (s > 1) will make stroke widths appear thinner, units smaller, and vice versa, i.e. affects $MapDrawingScale.
#    Can be an expression, just like the compression factor.
# rounding:
#    Scales up further to get rid of fractions if chosen correctly.
#    Doesn't play a role when determining bbox or locations and the like.
#    Can be an expression.
proc manipulateImage {imageArray {mirror 0} {rotate 0} {translateX 0} {translateY 0} {compress 1} {scale 1} {rounding 1}} {
	set manipulations {}

	if {[string length $mirror] && ($mirror != 0)} {
		switch -- $mirror 1 {
			lappend manipulations "mirrorX"
		} 2 {
			lappend manipulations "mirrorX" "mirrorY"
		} 3 {
			lappend manipulations "mirrorY"
		} default {
			assert false {Image mirror values are restricted to 0, 1, 2 and 3}
		}
	}

	if {[string length $rotate] && ($rotate != 0)} {
		switch -- $rotate 1 {
			lappend manipulations "tiltLeft"
		} 2 {
			lappend manipulations "tiltLeft" "tiltLeft"
		} 3 {
			lappend manipulations "tiltRight"
		} default {
			assert false {Image mirror values are restricted to 0, 1, 2 and 3}
		}
	}

	if {[string length $translateX]} {
		set translateX [expr $translateX]
	} else {
		set translateX 0
	}
	if {[string length $translateY]} {
		set translateY [expr $translateY]
	} else {
		set translateY 0
	}
	if {![Story::isEqual $translateX 0] || ![Story::isEqual $translateY 0]} {
		lappend manipulations "translate $translateX $translateY"
	}

	set scaleX 1
	set scaleY 1
	if {[string length $compress]} {
		set compress [expr $compress]
		assert {$compress > 0} {Compression factor should be strictly positive}
		if {$compress < 1} {
			set scaleX $compress
		} else {
			set scaleY [expr 1./$compress]
		}
	}
	if {[string length $scale]} {
		set scale [expr $scale]
		assert {$scale > 0} {Scale factor should be strictly positive}
		set scaleX [expr $scale * $scaleX]
		set scaleY [expr $scale * $scaleY]
	}
	if {![Story::isEqual $scaleX 1] || ![Story::isEqual $scaleY 1]} {
		lappend manipulations "scale $scaleX $scaleY"
	}
	
	if {[string length $rounding]} {
		set rounding [expr $rounding]
		assert {$rounding > 0} {Rounding scale factor should be strictly positive}
		if {![Story::isEqual $rounding 1]} {
			lappend manipulations "setRounding $rounding"
		}
	}

	# Apply manipulations
	foreach {color image} [$imageArray get] {
		foreach manipulation $manipulations {
			uplevel [list $image] $manipulation
		}
	}
}

proc includeOutline {name parent imagesDict outlines selections fillAct frontAct backAct {execAction ""} {alterGState 0}} {
	$parent addReference Global "" MapDrawingScale
	set inclusion [createChapter $name $parent]
	set roundingScale 0
	set scaler {}
	set isExecutable [string length $execAction]
	
	foreach {imageNames colors} $selections {
		foreach imageName $imageNames {
			if {![$imagesDict has $imageName]} {
				inform "Trace image $imageName for outline $name unspecified or empty. Skipped."
			} else {
				set imageArray [$imagesDict of $imageName]
				foreach color $colors {
					if {![$imageArray has $color]} {
						inform "Color $color not present in image $imageName for outline $name. Skipped."
					} else {
						set outlineName "Outline[capitalize $imageName][capitalize $color]"
						if {$isExecutable} {
							set outlineName "${outlineName}Exec"
						}
						set image [$imageArray of $color]
						# Scale down to get rid of the fractions in the image data
						set newRoundingScale [$image getRounding]
						if {![Story::isEqual $newRoundingScale $roundingScale]} {
							set scaler [createPlay [[$inclusion getSequence] makeUnique SwitchScale] $inclusion \
								\$MapDrawingScale "\$GlobalMapDrawingScale $newRoundingScale mul"]
							if {$alterGState} {
								if {[Story::isEqual $roundingScale 0]} {
									set scaleFactor [expr 1. / $newRoundingScale]
								} else {
									set scaleFactor [expr $roundingScale / $newRoundingScale]
								}
							} else {
								set scaleFactor [expr 1. / $newRoundingScale]
								$scaler appendToFront "s"
								$scaler appendToBack "r"
							}
							$scaler updateAttributes [list \$ScaleFactor $scaleFactor]
							if {![Story::isEqual $scaleFactor 1]} {
								$scaler appendToFront [list "\$ScaleFactor#4 dup x"]
							}
							if {$isExecutable} {
								lprepend fillAct $execAction
							}
							if {[llength $fillAct] == 1} {
								$scaler appendToFront [list "/fk \{[lindex $fillAct 0]\} bd"]
							} else {
								$scaler appendToFront [concat [list "/fk \{"] $fillAct [list "\} bd"]]
							}
							$scaler appendToFront $frontAct
							set roundingScale $newRoundingScale
						}
						if {![[$outlines getSequence] has $outlineName]} {
							set outline [createChapter $outlineName $outlines]
							if {$isExecutable} {
								set cloneImage [$image copy]
								$cloneImage updateAttributes {isExecutable 1}
								[$outline getSequence] acquire Outline $cloneImage
							} else {
								$imageArray unacquire $color
								[$outline getSequence] acquire Outline $image
							}
						}
						assert {[string length $scaler]} {"Front act for including outlines $inclusionName missing"}
						$scaler appendToFront $outlineName
					}
				}
			}
		}
	}
	if {$alterGState && ![Story::isEqual $roundingScale 0] && ![Story::isEqual $roundingScale 1]} {
		$inclusion updateAttributes [list \$ScaleFactor $roundingScale]
		$inclusion appendToBack [list "\$ScaleFactor#4 dup x"]
	}
	$inclusion appendToBack $backAct
	
	return $inclusion
}

proc applyNumberModifier {number modifier} {
	if {[string is double -strict $number]} {
		if {[Story::isEqual 0 $number]} {
			foreach {operand operator} $modifier {
				set ok 1
				switch -- $operator mul {} div {} default {
					set ok 0
					break
				}
			}
			if {$ok} {
				return 0
			}
		}
	}
	return "\{$number $modifier\}#"
}

proc applyModifier {param modifier modifierType} {
	if {![string length $modifier]} {return $param}
	switch $modifierType number {
		# Calculate and format
		return [applyNumberModifier $param $modifier]
	} numberlist {
		# Calculate and format each member
		return [lapply $param applyNumberModifier $modifier]
	} enum {
		# Replace
		return $modifier
	} default {
		# Append
		return [concat $param $modifier]
	}
}

proc createBorderStrokeAct {acts colorTracker isClosed isHalfWidth args} {
	global cMapParams cMapBorderParams cMapBorderModifiers cBorderModifierTypes
	
	if {![llength $args]} {
		return {}
	}

	set params $cMapBorderParams
	set runParams $cMapParams
	set modifiers $cMapBorderModifiers
	if {$isHalfWidth} {
		set modifiers [lreplace $modifiers 1 1 [concat [lindex $modifiers 1] "2 mul"]]
	}
	set paramsList {}
	set paintBorderList {}
	set strokeParamsList {}
	foreach {borderStrokeAct borderStrokeParams} $args {
		switch $borderStrokeAct "" {
			lprepend paintBorderList Border
			lprepend paramsList $params
			lprepend strokeParamsList $borderStrokeParams
		} CoastalBorder {
			lprepend paintBorderList Border
			lprepend paramsList $params
			lprepend strokeParamsList $borderStrokeParams
		} NationalBorder {
			lprepend paintBorderList Border
			lprepend paramsList [lreplace $params 1 1 2]
			lprepend strokeParamsList $borderStrokeParams
		} InternalBorder {
			lprepend paintBorderList Border
			lprepend paramsList [lreplace $params 2 3 {6 2} 3]
			lprepend strokeParamsList $borderStrokeParams
		} FrameBorder {
			lprepend paintBorderList InnerHalfBorder Border
			lprepend paramsList [lreplace $params 0 1 LandBrown 1] [lreplace $params 0 1 Black 4]
			foreach {outerStrokeParams innerStrokeParams} $borderStrokeParams {
				lprepend strokeParamsList $innerStrokeParams $outerStrokeParams
			}
		} Interior {
			lprepend paintBorderList Interior
			lprepend paramsList [lrange $params 0 0]
			lprepend strokeParamsList $borderStrokeParams
		} default {
			lprepend paintBorderList $borderStrokeAct
			lprepend paramsList $params
			lprepend strokeParamsList $borderStrokeParams
		}
	}

	set renderStrokeList {}
	set modifiersList {}
	set frontRun 1
	set execAction {}
	foreach paintBorder $paintBorderList {
		switch $paintBorder Border { 
			lappend renderStrokeList k
			lappend modifiersList $modifiers
		} Interior {
			lappend renderStrokeList f
			lappend modifiersList [lrange $modifiers 0 0]
		} default {
			assert {[[$acts getSequence] has "Paint$paintBorder"]} {
				"Stroke border name <Paint$paintBorder> in <$args> does not exist."
			}
			set paintBorderAct [[$acts getSequence] of "Paint$paintBorder"]
			set paintModifiers $modifiers
			if {!$isHalfWidth && [$paintBorderAct hasAttribute IsHalfWidth]} {
				if {[$paintBorderAct getAttribute IsHalfWidth]} {
					set paintModifiers [lreplace $paintModifiers 1 1 [concat [lindex $paintModifiers 1] "2 mul"]]
				}
			}					
			lappend modifiersList $paintModifiers
			if {[$paintBorderAct hasAttribute Executes]} {
				if {[$paintBorderAct getAttribute Executes]} {
					eval lappend execAction [lrepeat [$paintBorderAct getAttribute Executes] "dup"] 
				}
			}
			set paintAct [valueAct "Paint$paintBorder" $acts]
			if {[$paintBorderAct hasAttribute IsClipping]} {
				if {[$paintBorderAct getAttribute IsClipping]} {
					set paintAct [concat clipsave $paintAct cliprestore]
				}
			}
			lappend renderStrokeList $paintAct
		}
		set frontRun 0
	}
	if {[llength $execAction]} {
		lappend execAction "exec"
	}
								
	set frontAct {}
	set strokeAct {}
	set frontRun 1
	foreach strokeParams $strokeParamsList params $paramsList renderStroke $renderStrokeList modifiers $modifiersList {
		set actParams {}
		if {[llength $params] == 1} {
			set isFill 1
			set modifierTypes [lrange $cBorderModifierTypes 0 0]
			if {[llength $strokeParams] > 1} {
				inform "More than 1 fill parameter for <$strokeParams> in <$args>; last [expr [llength $strokeParams] - 1] ignored."
				set strokeParams [lrange $strokeParams 0 0]
			}
		} else {
			set isFill 0
			set modifierTypes $cBorderModifierTypes
			if {[llength $strokeParams] > [llength $params]} {
				inform "Too many stroke parameters for <$strokeParams> in <$args>; last [expr [llength $strokeParams] - [llength $params]] ignored."
				set strokeParams [lrange $strokeParams 0 [expr [llength $params] - 1]]
			}
		}
		foreach param $params strokeParam $strokeParams \
				modifier $modifiers modifierType $modifierTypes {
			if {[string length $strokeParam]} {
				set actParam $strokeParam
			} else {
				set actParam $param
			}
			lappend actParams [applyModifier $actParam $modifier $modifierType]
		}
		set strokeParamsAct {}
		if {$isFill} {
			set strokeColor [lindex $actParams 0]
			set runStrokeColor [lindex $runParams 0]
			if {![string equal $strokeColor $runStrokeColor]} {
				$colorTracker addColor [lindex $strokeColor 0]
				lappend strokeParamsAct $strokeColor
			}			
		} else {
			foreach {strokeColor lineWidth dashList dashInit lineCap lineJoin} $actParams \
					{runStrokeColor runLineWidth runDashList runDashInit runLineCap runLineJoin} $runParams {
				if {![string equal $lineWidth $runLineWidth]} {
					lappend strokeParamsAct "$lineWidth w"
				}
				if {![string equal $dashInit $runDashInit] || ![string equal $dashList $runDashList]} {
					lappend strokeParamsAct "\[[eval concat $dashList]\] $dashInit d"
				}
				if {![string equal $lineCap $runLineCap]} {
					lappend strokeParamsAct "$lineCap setlinecap"
				}
				if {![string equal $lineJoin $runLineJoin]} {
					lappend strokeParamsAct "$lineJoin setlinejoin"
				}
				if {![string equal $strokeColor $runStrokeColor]} {
					$colorTracker addColor [lindex $strokeColor 0]
					lappend strokeParamsAct $strokeColor
				}
			}
		}
		set strokeParamsAct [eval concat $strokeParamsAct]
		if {$frontRun} {
			lappend frontAct $strokeParamsAct
			lappend strokeAct $renderStroke
			if {$isFill} {
				set runParams [lreplace $runParams 0 0 [lindex $actParams 0]]
			} else {
				set runParams $actParams
			}
			set frontRun 0
		} else {
			lprepend strokeAct "s $strokeParamsAct $renderStroke r"
		}
	}
	if {$isClosed} {
		lprepend strokeAct p
	}

	return [list $frontAct $strokeAct $execAction]
}

proc listLocations {imagesDict selections} {
	set locations {}
	foreach {imageNames imageParameters} $selections {
		foreach imageName $imageNames {
			if {[$imagesDict has $imageName]} {
				foreach {color w h} $imageParameters { 
					set imageArray [$imagesDict of $imageName]
					if {[$imageArray has $color]} {
						set image [$imageArray of $color]
						eval lappend locations [$image listLocations $w $h]
					} else {
						inform "Color $color not present in location image $imageName."
					}
				}
			} else {
				inform "Location image $imageName unspecified. Skipped."
			}
		}
	}
	return $locations
}

proc selectImages {imageArray colors action actionArgs} {
	if {![llength $colors]} {
		set images [$imageArray get]
	} else {
		set images {}
		foreach color $colors {
			if {![$imageArray has $color]} {
				inform "Color <$color> not present in image"
				continue
			}
			eval lappend images [$imageArray get $color]
		}
	}
	foreach {color image} $images {
		eval $action [list $color $image] $actionArgs
	}
}

proc summarizeImage {color image} {
	global eTraceColors
	set cmykText "?"
	foreach {cmyk colorName} [$eTraceColors get] {
		if {$color == $colorName} {
			set cmykText $cmyk
			break
		}
	}
	inform "Color $color - CMYK = $cmykText - #curves = [llength [$image getCurves]]"
}

proc summarizeBorder {color image} {
	inform "Color $color:"
	foreach curve [$image getCurves] {
		set bbox [$curve getBBox]
		inform [eval list "Curve from [$curve getStartPoint] to [$curve getEndPoint]" \
			"centered at [Story::dedouble [expr ([lindex $bbox 0] + [lindex $bbox 2]) / 2.]] [Story::dedouble [expr ([lindex $bbox 1] + [lindex $bbox 3]) / 2.]]" \
			"size [Story::dedouble [expr [lindex $bbox 2] - [lindex $bbox 0]]] [Story::dedouble [expr [lindex $bbox 3] - [lindex $bbox 1]]]" \
		]
	}
}

proc summarizeLocation {color image {minCount 1}} {
	set sizes [iarray::Array #auto]
	foreach curve [$image getCurves] {
		set bbox [$curve getBBox]
		set size [list [Story::dedouble [expr [lindex $bbox 2] - [lindex $bbox 0]]] [Story::dedouble [expr [lindex $bbox 3] - [lindex $bbox 1]]]]
		$sizes set $size [concat [$sizes on $size {}] [list [list [Story::dedouble [expr ([lindex $bbox 0] + [lindex $bbox 2]) / 2.]] [Story::dedouble [expr ([lindex $bbox 1] + [lindex $bbox 3]) / 2.]]]]]
	}
	foreach {size locations} [$sizes get] {
		if {[llength $locations] >= $minCount} {
			inform "Color $color - Size $size - Locations $locations"
		} 
	}
	itcl::delete object $sizes
}

proc cleanUpCache {} {
	global eCacheDir 
	eval file delete [glob -directory $eCacheDir "*.eps"]
}
